open Lexical;;

type position = string * int * int * int;;

type error = (position * position) * string;;

type t = {
	state_f: char -> t -> t;
	buffer: string;
	push_queue: (token * (position * position)) list;
	pop_queue: (token * (position * position)) list;
	filename: string;
	offset: int;
	line: int;
	column: int;
	start_column: int;
	tab: int};;

let position (s: t): position = (
	s.filename, s.offset, s.line, s.column
);;

let single_position (s: t): position * position = (
	let p = position s in p, p
);;

let ranged_position (back: int) (s: t): position * position = (
	let start_position = s.filename, s.offset, s.line, s.start_column in
	let end_position = s.filename, s.offset, s.line, s.column - back in
	start_position, end_position
);;

let transit_0 (f: char -> t -> t) (c: char) (s: t): t = (
	let s = {s with state_f = f} in
	f c s
);;

let add_0 (t: token) (s: t): t = (
	{s with push_queue = (t, single_position s) :: s.push_queue}
);;

let add_0_with_error (message: string) (t: token) (s: t): t = (
	let p = single_position s in
	{s with push_queue = (t, p) :: (Lexical_error message, p) :: s.push_queue}
);;

let add_0_ranged ?(back: int = 1) (t: token) (f: char -> t -> t) (c: char) (s: t): t = (
	let s = {s with state_f = f;
	         start_column = s.column - back + 1;
	         push_queue = (t, ranged_position back s) :: s.push_queue} in
	f c s
);;

let add_0_ranged_with_error (message: string) (t: token) (f: char -> t -> t) (c: char) (s: t): t = (
	let s = {s with state_f = f;
	         push_queue = (t, ranged_position 1 s) :: (Lexical_error message, single_position s) :: s.push_queue} in
	f c s
);;

let skip_1 (s: t): t = (
	{s with offset = s.offset + 1; column = s.column + 1}
);;

let add_1 (t: token) (s: t): t = (
	{s with offset = s.offset + 1; column = s.column + 1;
	        push_queue = (t, single_position s) :: s.push_queue}
);;

let add_1_ranged (t: token) (f: char -> t -> t) (s: t): t = (
	{s with state_f = f;
	        offset = s.offset + 1; column = s.column + 1;
	        push_queue = (t, ranged_position 0 s) :: s.push_queue}
);;

let transit_1 (f: char -> t -> t) (s: t): t = (
	{s with state_f = f;
	        offset = s.offset + 1; column = s.column + 1}
);;

let start_1 (f: char -> t -> t) (s: t): t = (
	{s with state_f = f;
	        offset = s.offset + 1; column = s.column + 1; start_column = s.column}
);;

let start_1_with_buffer (f: char -> t -> t) (c: char) (s: t): t = (
	{s with state_f = f;
	        buffer = String.make 1 c;
	        offset = s.offset + 1; column = s.column + 1; start_column = s.column}
);;

let start_1_with_empty_buffer (f: char -> t -> t) (s: t): t = (
	{s with state_f = f;
	        buffer = "";
	        offset = s.offset + 1; column = s.column + 1; start_column = s.column}
);;

let take_and_transit_1 (f: char -> t -> t) (c: char) (s: t): t = (
	{s with state_f = f;
	        buffer = s.buffer ^ String.make 1 c;
	        offset = s.offset + 1; column = s.column + 1}
);;

let take_1 (c: char) (s: t): t = (
	{s with buffer = s.buffer ^ String.make 1 c;
	        offset = s.offset + 1; column = s.column + 1}
);;

let take_and_transit_2 (f: char -> t -> t) (c1: char) (c2: char) (s: t): t = (
	{s with state_f = f;
	        buffer = Printf.sprintf "%s%c%c" s.buffer c1 c2;
	        offset = s.offset + 1; column = s.column + 1}
);;

let take_tab (s: t): t = (
	let new_column = s.column + s.tab - (s.column - 1) mod s.tab in
	{s with buffer = s.buffer ^ "\t";
	        offset = s.offset + 1; column = new_column}
);;

let handle_tab (s: t): t = (
	let new_column = s.column + s.tab - (s.column - 1) mod s.tab in
	{s with offset = s.offset + 1; column = new_column}
);;

let handle_cr (s: t): t = (
	let state_f = s.state_f in
	{s with state_f = (fun c s -> match c with
	                              | '\n' -> {s with state_f = state_f;
	                                                offset = s.offset + 1}
	                              | _ -> state_f c {s with state_f = state_f});
	        offset = s.offset + 1; column = 1; line = s.line + 1}
);;

let handle_lf (s: t): t = (
	{s with offset = s.offset + 1; column = 1; line = s.line + 1}
);;

let token_of_string (s: string): token = (
	let u = String.uppercase s in
	if is_rw u then (
		Reserved (rw_of_string u)
	) else (
		Identifier s
	)
);;

let rec state_0 (c: char) (s: t): t = (
	match c with
	| ' ' -> skip_1 s
	| '\t' -> handle_tab s
	| '\r' -> handle_cr s
	| '\n' -> handle_lf s
	| '{' -> transit_1 state_comment s
	| '(' -> start_1 state_paren s
	| ')' -> add_1 Close_paren s
	| '[' -> add_1 Open_bracket s
	| ']' -> add_1 Close_bracket s
	| ':' -> start_1 state_colon s
	| ';' -> add_1 Semicolon s
	| '.' -> start_1 state_period s
	| ',' -> add_1 Comma s
	| '=' -> add_1 EQ s
	| '<' -> start_1 state_lt s
	| '>' -> start_1 state_gt s
	| '+' -> add_1 Plus s
	| '-' -> add_1 Minus s
	| '*' -> add_1 Asterisk s
	| '/' -> add_1 Slash s
	| '^' -> add_1 Caret s
	| '@' -> add_1 At s
	| 'A'..'Z' | 'a'..'z' | '_' -> start_1_with_buffer state_word c s
	| '0'..'9' -> start_1_with_buffer state_integer c s
	| '$' -> start_1_with_empty_buffer state_hex s
	| '\'' -> start_1_with_empty_buffer state_string s
	| '\x1a' -> add_0 EOF s
	| _ -> add_1 (Lexical_error (Printf.sprintf "invalid character #$%x." (int_of_char c))) s
) and state_comment (c: char) (s: t): t = (
	match c with
	| '\t' -> handle_tab s
	| '\r' -> handle_cr s
	| '\n' -> handle_lf s
	| '}' -> transit_1 state_0 s
	| '\x1a' -> add_0_with_error "comment shold be closed." EOF s
	| _ -> skip_1 s
) and state_alternate_comment (c: char) (s: t): t = (
	match c with
	| '\t' -> handle_tab s
	| '\r' -> handle_cr s
	| '\n' -> handle_lf s
	| '*' -> transit_1 state_alternate_comment_closing s;
	| '\x1a' -> add_0_with_error "comment shold be closed." EOF s
	| _ -> skip_1 s
) and state_alternate_comment_closing (c: char) (s: t): t = (
	match c with
	| ')' -> transit_1 state_0 s
	| _ -> transit_0 state_alternate_comment c s
) and state_paren (c: char) (s: t): t = (
	match c with
	| '*' -> transit_1 state_alternate_comment s
	| _ -> add_0_ranged Open_paren state_0 c s
) and state_colon (c: char) (s: t): t = (
	match c with
	| '=' -> add_1_ranged Assign state_0 s
	| _ -> add_0_ranged Colon state_0 c s
) and state_period (c: char) (s: t): t = (
	match c with
	| '.' -> add_1_ranged Range state_0 s
	| _ -> add_0_ranged Period state_0 c s
) and state_lt (c: char) (s: t): t = (
	match c with
	| '>' -> add_1_ranged NE state_0 s
	| '=' -> add_1_ranged LE state_0 s
	| _ -> add_0_ranged LT state_0 c s
) and state_gt (c: char) (s: t): t = (
	match c with
	| '=' -> add_1_ranged GE state_0 s
	| _ -> add_0_ranged GT state_0 c s
) and state_word (c: char) (s: t): t = (
	match c with
	| 'A'..'Z' | 'a'..'z' | '_' | '0'..'9' -> take_1 c s
	| _ -> add_0_ranged (token_of_string s.buffer) state_0 c s
) and state_integer (c: char) (s: t): t = (
	match c with
	| '0'..'9' -> take_1 c s
	| '.' -> transit_1 state_integer_and_period s
	| _ -> add_0_ranged (Integer (int_of_string s.buffer)) state_0 c s
) and state_integer_and_period (c: char) (s: t): t = (
	match c with
	| '0'..'9' -> take_and_transit_2 state_real '.' c s
	| '.' -> add_0_ranged ~back:2 (Integer (int_of_string s.buffer)) state_period c s
	| _ -> add_0_ranged (Real (float_of_string s.buffer)) state_0 c s
) and state_real (c: char) (s: t): t = (
	match c with
	| '0'..'9' -> take_1 c s
	| _ -> add_0_ranged (Real (float_of_string s.buffer)) state_0 c s
) and state_hex (c: char) (s: t): t = (
	match c with
	| '0'..'9' | 'A'..'F' | 'a'..'f' -> take_and_transit_1 state_valid_hex c s
	| _ -> add_0_ranged_with_error "invalid hexadecimal literal." (Integer 0) state_0 c s
) and state_valid_hex (c: char) (s: t): t = (
	match c with
	| '0'..'9' | 'A'..'F' | 'a'..'f' -> take_1 c s
	| _ -> add_0_ranged (Integer (int_of_string ("0x" ^ s.buffer))) state_0 c s
) and state_string (c: char) (s: t): t = (
	match c with
	| '\t' -> take_tab s
	| '\r' | '\n' -> add_0_ranged_with_error "string shold be closed." (String s.buffer) state_0 c s
	| '\'' -> transit_1 state_string_closing s
	| _ -> take_1 c s
) and state_string_closing (c: char) (s: t): t = (
	match c with
	| '\'' -> take_and_transit_1 state_string c s
	| _ -> add_0_ranged (String s.buffer) state_0 c s
);;

let create ~(tab: int) ~(filename: string): t = (
	{state_f = state_0; buffer = ""; push_queue = []; pop_queue = [];
	 filename = filename; offset = 0; line = 1; column = 1; start_column = 0; tab = tab}
);;

let post (c: char) (s: t): t = (
	s.state_f c s
);;

let is_empty (s: t): bool = (
	s.push_queue = [] && s.pop_queue = []
);;

let next (s: t): t * token * (position * position) = (
	match s.pop_queue with
	| (t, p) :: xr -> {s with pop_queue = xr}, t, p
	| [] -> match List.rev s.push_queue with
	        | (t, p) :: xr -> {s with push_queue = []; pop_queue = xr}, t, p
	        | [] -> failwith "Scanner.next"
);;
